perm filename PERMS.LSP[NBS,WD]1 blob
sn#231149 filedate 1976-08-11 generic text, type C, neo UTF8
COMMENT ā VALID 00007 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (DECLARE (SETQ BASE (SETQ IBASE 10.)))
C00005 00003 (DE EXCEPT1 (LST MIN MAX)
C00008 00004 (DE PRINTNUMBER (NUMBER RADIX SCALE)
C00011 00005 (SETQ KEYMAP @
C00013 00006 (SETQ S1 (QUOTE ((14 4 13 1 2 15 11 8 3 10 6 12 5 9 0 7)
C00016 00007 (DE PERMS (L)
C00018 ENDMK
Cā;
(DECLARE (SETQ BASE (SETQ IBASE 10.)))
(SETQ BASE (SETQ IBASE 10.))
(SETQ *NOPOINT T)
(DEFPROP CHECKIT
(LAMBDA (MIN MAX L)
(PROG (ANS ELT MULT)
(SETQ ELT MIN)
LOOP (COND ((GREATERP ELT MAX) (RETURN (REVERSE ANS))))
(SETQ MULT (COUNTEM ELT L))
(COND ((NOT (EQ MULT 1))
(SETQ ANS (CONS (CONS ELT MULT) ANS))))
(SETQ ELT (ADD1 ELT))
(GO LOOP)))
EXPR)
(DE CHOICE (PC L)
(PROG (RES)
LOOP (COND ((NULL PC) (RETURN (REVERSE RES))))
(SETQ RES (CONS (NTH (CAR PC) L) RES))
(SETQ PC (CDR PC))
(GO LOOP)))
(DE COLUMNPRINT (WDTH LST)
(PROG (CNT)
LOOP(SETQ CNT 0)
(TERPRI)
ILOOP(COND ((NULL LST) (TERPRI) (TERPRI) (RETURN NIL)))
(COND ((EQUAL CNT WDTH) (GO LOOP)))
(PRINC @ / )
(PRINTNUMBER (CAR LST) 10 99)
(SETQ LST (CDR LST))
(SETQ CNT (ADD1 CNT))
(GO ILOOP)))
(DE COUNTEM (N L)
(PROG NIL
(SETQ M 0)
LOOP (COND ((NULL L) (RETURN M)))
(COND ((EQ (CAR L) N) (SETQ M (ADD1 M))))
(SETQ L (CDR L))
(GO LOOP)))
(DE EXCEPT (SH PCIN PCOUT MIN MAX)
(PROG (CNT)
(SETQ CNT 0)
LOOP (COND ((NULL SH) (RETURN NIL)))
(SETQ CNT (ADD1 CNT))
(SETQ PCIN (LIST (ROT (CAR SH) (CAR PCIN)) (ROT (CAR SH) (CADR PCIN))))
(PRINC (READLIST (CONS (QUOTE K) (EXPLODE CNT))))
(PRINC @ / )
(PRINTLIST (EXCEPT1 (CHOICE PCOUT (APPEND (CAR PCIN) (CADR PCIN))) MIN MAX))
(TERPRI)
(SETQ SH (CDR SH))
(GO LOOP)))
(DE EXCEPT1 (LST MIN MAX)
(PROG (CNT EXC)
(SETQ CNT MIN)
LOOP (COND ((GREATERP CNT MAX) (RETURN (REVERSE EXC))))
(COND ((NOT (MEMBER CNT LST)) (SETQ EXC (CONS CNT EXC))))
(SETQ CNT (ADD1 CNT))
(GO LOOP)))
(DE KEYSCH (SH PCIN PCOUT WIDTH)
(PROG (CNT)
(SETQ CNT 0)
LOOP (COND ((NULL SH) (RETURN NIL)))
(SETQ CNT (ADD1 CNT))
(SETQ PCIN (LIST (ROT (CAR SH) (CAR PCIN)) (ROT (CAR SH) (CADR PCIN))))
(PRINC (QUOTE / / / / / / / ))
(PRINC (READLIST (CONS (QUOTE K) (EXPLODE CNT))))
(TERPRI)
(COLUMNPRINT WIDTH (CHOICE PCOUT (APPEND (CAR PCIN) (CADR PCIN))))
(TERPRI)
(SETQ SH (CDR SH))
(GO LOOP)))
(DE MAXIMUM (L)
(PROG (MOST)
LOOP (COND ((NULL L) (RETURN MOST)))
(COND ((NOT (GREATERP MOST (CAR L))) (SETQ MOST (CAR L))))
(SETQ L (CDR L))
(GO LOOP)))
(DE MINIMUM (L)
(PROG (LEAST)
LOOP (COND ((NULL L) (RETURN LEAST)))
(COND ((NOT (GREATERP (CAR L) LEAST)) (SETQ LEAST (CAR L))))
(SETQ L (CDR L))
(GO LOOP)))
(DE NTH (N L)
(PROG NIL
LOOP (COND ((EQ N 1) (RETURN (CAR L))))
(SETQ N (SUB1 N))
(SETQ L (CDR L))
(GO LOOP)))
(DE PRINTLIST (LST)
(PROG NIL
LOOP (COND ((NULL LST) (RETURN NIL)))
(PRINC (CAR LST))
(PRINC @ / )
(SETQ LST (CDR LST))
(GO LOOP)))
(DE PRINCSP (NUM)
(PROG NIL
LOOP (COND ((ZEROP NUM) (RETURN NIL)))
(PRINC (QUOTE / ))
(SETQ NUM (SUB1 NUM))
(GO LOOP)))
(DE PRINTNUMBER (NUMBER RADIX SCALE)
(PROG (BASE)
(SETQ BASE RADIX)
(PRINCSP (*DIF (FLATSIZE SCALE) (FLATSIZE NUMBER)))
(PRINC NUMBER)))
(DE ROT (N L)
(PROG NIL
LOOP (COND ((ZEROP N) (RETURN L)))
(SETQ N (SUB1 N))
(SETQ L (APPEND (CDR L) (LIST (CAR L))))
(GO LOOP)))
(DE SFLAT (SBOX)
(PROG (N ANS BASE IBASE)
(SETQ N 0)
(SETQ BASE (SETQ IBASE 2))
LOOP (COND ((GREATERP N 63) (RETURN (REVERSE ANS))))
(SETQ ANS (CONS (SLOOK N SBOX) ANS))
(SETQ N (ADD1 N))
(GO LOOP)))
(DE SLOOK (NUM SBOX)
(PROG (A D EN I J BASE IBASE)
(SETQ BASE (SETQ IBASE 2))
(SETQ EN (CDR (EXPLODE (PLUS NUM 64))))
(SETQ A (CAR EN))
(SETQ D (REVERSE (CDR EN)))
(SETQ I (READLIST (LIST A (CAR D))))
(SETQ J (READLIST (REVERSE (CDR D))))
(RETURN (SLOOK1 I J SBOX))))
(DE SLOOK1 (I J SBOX) (NTH (ADD1 J) (NTH (ADD1 I) SBOX)))
(SETQ KEYMAP @
(1 2 3 4 5 6 7 P 8 9 10 11 12 13 14 P 15 16 17 18 19 20 21 P
22 23 24 25 26 27 28 P 29 30 31 32 33 34 35 P 36 37 38 39 40 41 42 P
43 44 45 46 47 48 49 P 50 51 52 53 54 55 56 P 57 58 59 60 61 62 63 P))
(SETQ PC1 @ ((57 49 41 33 25 17 9 1 58 50 42 34 26 18 10 2 59 51 43 35 27 19 11
3 60 52 44 36) (63 55 47 39 31 23 15 7 62 54 46 38 30 22 14 6 61 53 45 37 29 21
13 5 28 20 12 4)))
(SETQ BITS0TO55
@ ((0 1 2 3 4 5 6 7 8 9 10 11 12 13
14 15 16 17 18 19 20 21 22 23 24 25 26 27)
(28 29 30 31 32 33 34 35 36 37 38 39 40 41
42 43 44 45 46 47 48 49 50 51 52 53 54 55)))
(SETQ PC1C (CAR PC1))
(SETQ PC1D (CADR PC1))
(SETQ NPC1C (CHOICE PC1C KEYMAP))
(SETQ NPC1D (CHOICE PC1D KEYMAP))
(SETQ PC2
@ (14 17 11 24 1 5 3 28
15 6 21 10 23 19 12 4
26 8 16 7 27 20 13 2
41 52 31 37 47 55 30 40
51 45 33 48 44 49 39 56
34 53 46 42 50 36 29 32))
(SETQ PC2A
@ (14 17 11 24 1 5 3 28
15 6 21 10 23 19 12 4
26 8 16 7 27 20 13 2))
(SETQ PC2B
@ (41 52 31 37 47 55 30 40
51 45 33 48 44 49 39 56
34 53 46 42 50 36 29 32))
(SETQ SHIFTS @ (1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1))
(SETQ S1 (QUOTE ((14 4 13 1 2 15 11 8 3 10 6 12 5 9 0 7)
(0 15 7 4 14 2 13 1 10 6 12 11 9 5 3 8)
(4 1 14 8 13 6 2 11 15 12 9 7 3 10 5 0)
(15 12 8 2 4 9 1 7 5 11 3 14 10 0 6 13))))
(SETQ S2 (QUOTE ((15 1 8 14 6 11 3 4 9 7 2 13 12 0 5 10)
(3 13 4 7 15 2 8 14 12 0 1 10 6 9 11 5)
(0 14 7 11 10 4 13 1 5 8 12 6 9 3 2 15)
(13 8 10 1 3 15 4 2 11 6 7 12 0 5 14 9))))
(SETQ S3 (QUOTE ((10 0 9 14 6 3 15 5 1 13 12 7 11 4 2 8)
(13 7 0 9 3 4 6 10 2 8 5 14 12 11 15 1)
(13 6 4 9 8 15 3 0 11 1 2 12 5 10 14 7)
(1 10 13 0 6 9 8 7 4 15 14 3 11 5 2 12))))
(SETQ S4 (QUOTE ((7 13 14 3 0 6 9 10 1 2 8 5 11 12 4 15)
(13 8 11 5 6 15 0 3 4 7 2 12 1 10 14 9)
(10 6 9 0 12 11 7 13 15 1 3 14 5 2 8 4)
(3 15 0 6 10 1 13 8 9 4 5 11 12 7 2 14))))
(SETQ S5 (QUOTE ((2 12 4 1 7 10 11 6 8 5 3 15 13 0 14 9)
(14 11 2 12 4 7 13 1 5 0 15 10 3 9 8 6)
(4 2 1 11 10 13 7 8 15 9 12 5 6 3 0 14)
(11 8 12 7 1 14 2 13 6 15 0 9 10 4 5 3))))
(SETQ S6 (QUOTE ((12 1 10 15 9 2 6 8 0 13 3 4 14 7 5 11)
(10 15 4 2 7 12 9 5 6 1 13 14 0 11 3 8)
(9 14 15 5 2 8 12 3 7 0 4 10 1 13 11 6)
(4 3 2 12 9 5 15 10 11 14 1 7 6 0 8 13))))
(SETQ S7 (QUOTE ((4 11 2 14 15 0 8 13 3 12 9 7 5 10 6 1)
(13 0 11 7 4 9 1 10 14 3 5 12 2 15 8 6)
(1 4 11 13 12 3 7 14 10 15 6 8 0 5 9 2)
(6 11 13 8 1 4 10 7 9 5 0 15 14 2 3 12))))
(SETQ S8 (QUOTE ((13 2 8 4 6 15 11 1 10 9 3 14 5 0 12 7)
(1 15 13 8 10 3 7 4 12 5 6 11 0 14 9 2)
(7 11 4 1 9 12 14 2 0 6 10 13 15 3 5 8)
(2 1 14 7 4 10 8 13 15 12 9 0 3 5 6 11))))
(DE PERMS (L)
(COND ((NULL L) (LIST NIL)) (T (RUNTHRU (CAR L) (PERMS (CDR L))))))
(DE RUNTHRU (E L)
(PROG (ANS)
LOOP (COND ((NULL L) (RETURN ANS)))
(SETQ ANS (APPEND ANS (RUNTHRU1 E (CAR L))))
(SETQ L (CDR L))
(GO LOOP)))
(DE RUNTHRU1 (E L)
(PROG (FRONT BACK ANS)
(SETQ BACK L)
LOOP (SETQ ANS (CONS (APPEND FRONT (LIST E) BACK) ANS))
(COND ((NULL BACK) (RETURN (REVERSE ANS))))
(SETQ FRONT (APPEND FRONT (LIST (CAR BACK))))
(SETQ BACK (CDR BACK))
(GO LOOP)))
(DE PRINL (L) (MAPC (FUNCTION PRINC) L))
(DE NTHCDR (N L) (COND ((ZEROP N) L) (T (NTHCDR (SUB1 N) (CDR L)))))
(DE PROD (P Q)
(PROG (PROD)
LOOP (COND ((NULL P) (RETURN (REVERSE PROD))))
(SETQ PROD (CONS (CAR (NTHCDR (SUB1 (CAR P)) Q)) PROD))
(SETQ P (CDR P))
(GO LOOP)))
(DE SQUARE (P) (PROD P P))
(DE LISTSQUARES (L)
(PROG (PS SQ)
(SETQ PS (PERMS L))
LOOP (COND ((NULL PS) (RETURN NIL)))
(PRINL (CAR PS))
(PRINC (QUOTE / / / ))
(SETQ SQ (SQUARE (CAR PS)))
(COND ((NOT (EQUAL SQ L)) (PRINC (QUOTE / / ))))
(PRINL SQ)
(TERPRI)
(SETQ PS (CDR PS))
(GO LOOP)))